home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Thomas / run-top.scm < prev    next >
Encoding:
Text File  |  1992-11-25  |  8.4 KB  |  195 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.  
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-top.scm,v 1.2 1992/09/11 15:30:09 jmiller Exp $
  39.  
  40. ;;;; Utility procedures for the runtime system only.
  41.  
  42. (define (get-type obj)
  43.   (cond ((instance? obj) (instance.class obj))
  44.     ((number? obj)            ; Might be wrong
  45.      (if (real? obj)
  46.          (if (exact? obj)
  47.          (if (integer? obj)
  48.              <integer>
  49.              <ratio>)
  50.          <float>)
  51.          <complex>))
  52.     ((class? obj) <class>)
  53.     ((singleton? obj) <singleton>)
  54.     ((null? obj) <empty-list>)
  55.     ((slot? obj) <slot-descriptor>)
  56.     ((pair? obj) <pair>)
  57.     ((vector? obj) <simple-object-vector>)
  58.     ((string? obj) <byte-string>)
  59.     ((char? obj) <character>)
  60.     ((procedure? obj)
  61.      (cond ((dylan::generic-function? obj) <generic-function>)
  62.            ((dylan::method? obj) <method>)
  63.            (else <function>)))
  64.     ((keyword? obj) <keyword>)
  65.     ((symbol? obj) <symbol>)
  66.     (else <object>)))
  67.  
  68. (define (dylan-list-length l)
  69.   ; Returns >= 0  for finite proper lists
  70.   ;          = -1 for infinite lists
  71.   ;          = (size + 1) for improper lists, where size is the "proper list"
  72.   ;                       portion of the list
  73.   (define (phase-1 l1 l2 n)
  74.     (cond ((pair? l1) (phase-2 (cdr l1) l2 (+ n 1)))
  75.       ((null? l1) n)
  76.       (else (+ n 1))))
  77.   (define (phase-2 l1 l2 n)
  78.     (cond ((eq? l1 l2) -1)        ; Circular list.
  79.       ((pair? l1) (phase-1 (cdr l1) (cdr l2) (+ n 1)))
  80.       ((null? l1) n)
  81.       (else (+ n 1))))
  82.   (phase-1 l l 0))
  83.  
  84. (define (dylan::keyword-validate next-method arglist allowed)
  85.   (if (procedure? next-method)
  86.       ;; Assume that the generic function has checked the content of `args'.
  87.       #T
  88.       (validate-keywords arglist allowed
  89.              (lambda args (dylan-apply dylan:error args)))))
  90.  
  91. ;;;
  92. ;;; MACROS for make-param-list argument 
  93. ;;;
  94.  
  95. (define only-rest-args (make-param-list `() #F 'REST-ARGS #F))
  96. (define function-and-arguments 
  97.   (make-param-list `((FUNCTION ,<function>)) #F 'REST-FNS #F))
  98. (define procedure-and-at-least-one-collection
  99.   (make-param-list `((PROCEDURE ,<function>) (COLLECTION ,<collection>))
  100.            #F 'REST #F))
  101.  
  102. ;; one-<xxx>
  103. (define one-number (make-param-list `((NUMBER ,<number>)) #F #F #F))
  104. (define one-object (make-param-list `((OBJECT ,<object>)) #F #F #F))
  105. (define one-list (make-param-list `((LIST ,<list>)) #F #F #F))
  106. (define one-function (make-param-list `((FUNCTION ,<function>)) #F #F #F))
  107. (define one-real (make-param-list `((REAL ,<real>)) #F #F #F))
  108. (define one-integer (make-param-list `((INTEGER ,<integer>)) #F #F #F))
  109. (define one-class (make-param-list `((CLASS ,<class>)) #F #F #F))
  110. (define one-slot (make-param-list `((SLOT ,<slot-descriptor>)) #F #F #F))
  111. (define one-char (make-param-list `((CHARACTER ,<character>)) #F #F #F))
  112. (define one-string (make-param-list `((STRING ,<string>)) #F #F #F))
  113. (define one-byte-string 
  114.   (make-param-list `((BYTE-STRING ,<byte-string>)) #F #F #F))
  115. (define one-collection (make-param-list `((COLLECTION ,<collection>)) #F #F #F))
  116. (define one-vector (make-param-list `((VECTOR ,<vector>)) #F #F #F))
  117. (define one-stretchy-vector 
  118.   (make-param-list `((STRETCHY-VECTOR ,<stretchy-vector>)) #F #F #F))
  119. (define one-simple-object-vector
  120.   (make-param-list `((SIMPLE-OBJECT-VECTOR ,<simple-object-vector>)) #F #F #F))
  121. (define one-sequence (make-param-list `((SEQUENCE ,<sequence>)) #F #F #F))
  122. (define one-deque (make-param-list `((DEQUE ,<deque>)) #F #F #F))
  123. (define one-range (make-param-list `((RANGE ,<range>)) #F #F #F))
  124. (define one-table (make-param-list `((TABLE ,<table>)) #F #F #F))
  125.  
  126. ;; at-least-one-<xxx>
  127. (define at-least-one-number 
  128.   (make-param-list `((NUMBER ,<number>)) #F 'REST-ARGS #F))
  129. (define at-least-one-function 
  130.   (make-param-list `((FUNCTION ,<function>)) #F 'REST-FNS #F))
  131. (define at-least-two-objects
  132.   (make-param-list `((OBJECT-1 ,<object>) (OBJECT-2 ,<object>)) #F 'REST #F))
  133. (define at-least-one-real (make-param-list `((REAL ,<real>)) #F 'REST-REAL #F))
  134. (define at-least-one-list (make-param-list `((FIRST-LIST ,<list>)) #F 'REST #F))
  135. (define at-least-one-sequence
  136.   (make-param-list `((SEQUENCE ,<sequence>)) #F 'REST #F))
  137.  
  138. ;; two-<xxx>
  139. (define two-objects
  140.   (make-param-list `((OBJECT-1 ,<object>) (OBJECT-2 ,<object>)) #F #F #F))
  141. (define two-collections
  142.   (make-param-list
  143.    `((COLLECTION-1 ,<collection>) (COLLECTION-2 ,<collection>)) #F #F #F))
  144. (define two-sequences
  145.   (make-param-list 
  146.    `((SEQUENCE-1 ,<sequence>) (SEQUENCE-2 ,<sequence>)) #F #F #F))
  147. (define two-numbers
  148.   (make-param-list `((NUMBER-1 ,<number>) (NUMBER-2 ,<number>)) #F #F #F))
  149. (define two-reals
  150.   (make-param-list `((REAL-1 ,<real>) (REAL-2 ,<real>)) #F #F #F))
  151. (define two-integers
  152.   (make-param-list `((INTEGER-1 ,<integer>) (INTEGER-2 ,<integer>)) #F #F #F))
  153. (define two-ranges
  154.   (make-param-list `((RANGE-1 ,<range>) (RANGE-2 ,<range>)) #F #F #F))
  155. (define two-lists
  156.   (make-param-list `((LIST-1 ,<list>) (LIST-2 ,<list>)) #F #F #F))
  157. (define two-strings 
  158.   (make-param-list `((STRING-1 ,<string>) (STRING-2 ,<string>)) #F #F #F))
  159. (define two-tables
  160.   (make-param-list `((TABLE-1 ,<table>) (TABLE-2 ,<table>)) #F #F #F))
  161.  
  162. ;; one-<xxx>-and-one-<zzz>
  163. (define one-sequence-and-an-object
  164.   (make-param-list `((SEQUENCE ,<sequence>) (OBJECT ,<object>)) #F #F #F))
  165. (define one-mutable-sequence-and-an-object
  166.   (make-param-list 
  167.    `((MUTABLE-SEQUENCE ,<mutable-sequence>) (OBJECT ,<object>)) #F #F #F))
  168. (define one-vector-and-an-object
  169.   (make-param-list `((VECTOR ,<vector>) (OBJECT ,<object>)) #F #F #F))
  170. (define one-simple-object-vector-and-an-object
  171.   (make-param-list 
  172.    `((SIMPLE-OBJECT-VECTOR ,<simple-object-vector>) (OBJECT ,<object>)) #F #F #F))
  173. (define one-string-and-an-object
  174.   (make-param-list `((STRING ,<string>) (OBJECT ,<object>)) #F #F #F))
  175. (define one-byte-string-and-an-object
  176.   (make-param-list `((BYTE-STRING ,<byte-string>) (OBJECT ,<object>)) #F #F #F))
  177. (define one-list-and-an-object
  178.   (make-param-list `((LIST ,<list>) (OBJECT ,<object>)) #F #F #F))
  179. (define one-stretchy-vector-and-an-object
  180.   (make-param-list `((STRETCHY-VECTOR ,<stretchy-vector>) (OBJECT ,<object>)) 
  181.            #F #F #F))
  182. (define one-collection-and-a-state
  183.   (make-param-list `((COLLECTION ,<collection>) (STATE ,<object>)) #F #F #F))
  184. (define one-deque-and-a-value
  185.   (make-param-list `((DEQUE ,<deque>) (OBJECT ,<object>)) #F #F #F))
  186. (define one-range-and-an-object
  187.   (make-param-list `((RANGE ,<range>) (OBJECT ,<object>)) #F #F #F))
  188. (define one-deque-and-an-object
  189.   (make-param-list `((DEQUE ,<deque>) (OBJECT ,<object>)) #F #F #F))
  190.   
  191. ;;; The File compiler.scm contains the definition of
  192. ;;; dylan::scheme-names-of-predefined-names, which must be kept up to
  193. ;;; date with the actual methods/classes/functions defined in the
  194. ;;; runtime system.
  195.